(in-package :licada)

(defun export-class(class-or-symbol)
  (let ((cls (if (symbolp class-or-symbol)(find-class class-or-symbol) class-or-symbol)))
    (export (class-name cls) )
    (flet ((export-symbol (sym)(export sym )))
      (mapc (lambda (slot)
	      (mapc #'export-symbol (slot-definition-readers slot))
	      (mapc #'export-symbol (slot-definition-writers slot)))
	    (class-direct-slots cls)))
    cls ))
(export 'export-class)

(defun get-or-create-package( pkg-name )
  (let ((pkg (find-package pkg-name)))
    (if (null pkg)
      (make-package pkg-name)
      pkg )))
(export 'get-or-create-package)

(defun register-symbol (pkg-name symbol-name)
  (let* ((pkg (if (null pkg-name)(find-package :keyword)(get-or-create-package pkg-name)))
	 (symbol (intern symbol-name pkg)))
    (export symbol pkg)))
(export 'register-symbol)

(defmacro with-gensyms (names &body forms)
  `(let ,(mapcar #'(lambda (name) (list name '(gensym))) names)
     ,@forms))
(export 'with-gensyms)

(defmacro char-str-tok(in-string in-split in-token &body body)
  "Tokenize a string.  This expects exactly one character between
tokens, it does not handle situations where there can be two or more"
  (with-gensyms ( nextpos str split start next strlen )
    `(flet ((,nextpos (str search start)
	     (let ((next (position search str :test #'char= :start start)))
	       (if (null next)
	         (length str)
		 next ))))
      (let* ((,str ,in-string)
	      (,split ,in-split)
	      (,strlen (length ,str)))
       (do* ((,start 0 (if (< (+ ,next 1) ,strlen)(+ ,next 1) ,strlen))
	     (,next (,nextpos ,str ,split ,start) (,nextpos ,str ,split ,start))
	     (,in-token (subseq ,str ,start ,next) (subseq ,str ,start ,next)))
	   ((= ,start ,strlen))
	 ,@body)))))
(export 'char-str-tok)

(defun whitespace-char-p (char)
  "Is char a whitespace character ?"
  (declare (type character char))
  (or (char= char #\space)
      (char= char #\tab)
      (char= char #\return)
      (char= char #\linefeed)))
(export 'whitespace-char-p)

(defun next-desired-pair(seq test-meth start)
  "Returns two values where the first is where test-meth is false, and
the second is the position (after the first) where test-meth is true"
  (let* ((first (position-if (lambda (arg)(not(funcall test-meth arg))) seq :start start))
	 (second (if first
		     (position-if test-meth seq :start (+ first 1) )
		     nil ))
	 (len (length seq )))
    (cons (if first first len ) (if second second len ))))
(export 'next-desired-pair)

(defun list-desired-pairs(seq test-meth)
  "List the desired pairs"
  (let ((retval)
	(len (length seq)))
    (do ((pair (next-desired-pair seq test-meth 0) (next-desired-pair seq test-meth (cdr pair))))
	 ((= len (car pair)))
      (push pair retval))
    (nreverse retval )))
(export 'list-desired-pairs)

(defun list-desired-subseq(seq test-meth)
  "List the desired subsequences"
  (mapcar (lambda (pair) (subseq seq (car pair) (cdr pair)))
	  (list-desired-pairs seq test-meth)))
(export 'list-desired-subseq)
	   

(defmacro general-tok(in-seq in-test-meth token-name &body body)
  "Tokenize a string based generally on any test.  This filters long
strings where (test-meth char) is true also, so token-name will never
have anything but test-meth characters.  test-meth must be a
generalized boolean"
  (with-gensyms ( pair seq test-meth len )
    `(let* ((,seq ,in-seq)
	   (,test-meth ,in-test-meth)
	   (,len (length ,seq)))
      (do* ((,pair (next-desired-pair ,seq ,test-meth 0 ) (next-desired-pair ,seq ,test-meth (cdr ,pair)))
	    (,token-name (subseq ,seq (car ,pair) (cdr ,pair)) (subseq ,seq (car ,pair) (cdr ,pair))))
	   ((= ,len (car ,pair)))
	,@body))))

(export 'general-tok)

;;Returns list length quickly up to 1
;;Any length greater than 1 is returned as 2
(defun list-len-0-or-1(list)
  (if (null list)
      0
    (if(null (cdr list))
	1
      2)))

(export 'list-len-0-or-1)

(defmacro while (test &body body)
  `(do ()
       ((not ,test))
     ,@body))
(export 'while)




